home *** CD-ROM | disk | FTP | other *** search
/ Super CD / Super CD.iso / geomitri / acad10 / aflix.lsp < prev    next >
Lisp/Scheme  |  1988-09-20  |  32KB  |  901 lines
  1. ;
  2. ;       Generate cameras and scenes to walk through drawing
  3. ;       or perform kinetic animation.
  4. ;
  5. ;       Last updated in release 1.0a
  6. ;
  7. ;       Designed and implemented by Kelvin R. Throop in May of 1987.
  8. ;
  9. ;       8/88  TLD/KWL -- Modified for Release 10.
  10. ;
  11. ;       This command takes a polyline, specifying the path and eye
  12. ;       height (from the polyline's elevation), and generates cameras
  13. ;       and scenes to walk through the model along the polyline.  It
  14. ;       simultaneously writes an AutoShade script file to generate
  15. ;       the images for each frame, and an AutoFlix command file
  16. ;       to create a movie from the frame images.  The camera's look-at
  17. ;       point can either be fixed or can be specified by a second
  18. ;       polyline, allowing either examination of a fixed point
  19. ;       from different viewpoints or a true Steadicam-type walkthrough.
  20. ;       In addition, the camera may be smoothly twisted throughout
  21. ;       the walkthrough, permitting inspection from various angles.
  22. ;
  23. ;       The generated script normally uses full shading to make the
  24. ;       images.  To change this to fast shading, or to subsequently
  25. ;       change back to full shade, use the command SHADETYPE.
  26. ;
  27.  
  28. (vmon)
  29. (setq shadecmd "fullshade")
  30. (setq flixver "1.0b")
  31.  
  32. ;       SHADETYPE command.  Permits user to select fast or full shaded
  33. ;                           renderings for animation frames.
  34.  
  35. (defun C:shadetype ()
  36.         (setq prcd T)
  37.         (while prcd
  38.            (setq s (strcase (substr (getstring (strcat "\nFast shading for images? <"
  39.               (if (= shadecmd "fastshade") "Y" "N")
  40.               ">: ")) 1 1)))
  41.            (cond
  42.               ((= (strlen s) 0) (setq prcd nil))
  43.               ((= s "Y") (setq prcd nil shadecmd "fastshade"))
  44.               ((= s "N") (setq prcd nil shadecmd "fullshade"))
  45.            )
  46.         )
  47.         (princ)
  48. )
  49.  
  50. ;       Construct item name from type code B, base name, and index N
  51.  
  52. (defun cname (b n)
  53.         (strcat b bname (itoa n))
  54. )
  55.  
  56. ;       ICL  -- Insert camera or light.  Presently used only for cameras
  57.  
  58. (defun icl (blkn lfxy laxy sname / scale slayer rot)
  59.         (setq scale (/ (getvar "VIEWSIZE") 9.52381))
  60.         (setq rot (* (/ 180 pi) (- (angle lfxy laxy) 1.570796)))
  61.         (setq laxy (trans laxy 1 0))
  62.         (command
  63.            "insert"
  64.               blkn
  65.               lfxy
  66.               scale
  67.               scale
  68.               (strcat "<<" (rtos rot 2 6))
  69.               sname                     ; SNAME
  70.               " "                       ; GNAME
  71.               (rtos (car laxy) 2 6)     ; LAX
  72.               (rtos (cadr laxy) 2 6)    ; LAY
  73.               (rtos (caddr laxy) 2 6)   ; LAZ
  74.         )
  75. )
  76.  
  77. ;       ISH  -- Insert scene/set/shot/whatever the heck we're calling it today
  78.  
  79. (defun ish (sname otype oname / omode slayer)
  80.         (command
  81.            "insert"
  82.               "shot"
  83.               (list '2 '2)
  84.               1                               ; No x scaling
  85.               1                               ; No y scaling
  86.               "<<0"                           ; No rotation
  87.               otype                           ; Object type
  88.               oname                           ; Object name
  89.               sname                           ; Scene name
  90.         )
  91. )
  92.  
  93. ; SLOB   Select Object
  94.  
  95. ; Selects one of the active object types.
  96. ; Won't take NULL for an answer.
  97.  
  98. ; Input:  prefix prompt
  99. ;         postfix prompt
  100. ;         Null pick ok flag
  101.  
  102. ;         Uses global objct
  103.  
  104. ; Return: entity
  105.  
  106. (defun slob (pre post nulok / prcd)
  107.  
  108.   (setq prcd 1)
  109.  
  110. ;   Select the object to update.
  111.  
  112.   (while (= 1 prcd)
  113.      (setq ename (car (entsel (strcat pre (strcase objct t) post))))
  114.      (if ename
  115.         (if (= (cdr (assoc '0 (setq elist (entget ename)))) "INSERT")
  116.            (progn
  117.               (setq bnam (cdr (assoc '2 elist)))
  118.               (cond
  119.                  ; Inserted block must have the desired object name.
  120.                  ((or
  121.                     (= objct bnam)
  122.                     (and (= bnam "DIRECT") (= objct "LIGHT"))
  123.                     (and (= bnam "OVERHEAD") (= objct "LIGHT"))
  124.                     (and (= bnam "SHOT") (= objct "SCENE")))
  125.                     (setq prcd nil)
  126.                  )
  127.                  (T
  128.                     (prompt (strcat "\nSelected object is not a "
  129.                        (strcase objct t) " \n")))
  130.               )
  131.            )
  132.         )
  133.         (if nulok
  134.            (setq prcd nil))
  135.      )
  136.   )
  137.   ename
  138. )
  139.  
  140. ; bget (ename)
  141.  
  142. ; Starting at ENAME entity name it searches the database for an SEQEND
  143. ; entity . The following list is returned:
  144.  
  145. ;   (elist0   elist1   elist2   ...   elistN), where
  146.  
  147. ;      elist0    Is the block's entity list
  148.  
  149. ;      elist<i>, i=1,N are the entities lists of the block's attributes
  150.  
  151. ; If the desired INSERT entity is not found nil is returned
  152.  
  153. ; Input:  ename     - Where to start the search.
  154.  
  155. ; Return: blist     - A global value
  156.  
  157. (defun bget ( ename / prcd elist)
  158.  
  159.   (setq prcd 1)
  160.  
  161. ; Before starting, see if the current blist contains
  162. ; the desired entity.
  163.  
  164.   (cond
  165.      ((and (listp 'blist) (= ename (cdr (assoc '-1 (car blist)))))
  166.         (ename))
  167.  
  168.      (T
  169.         (setq blist (list (entget ename)))
  170.         (while prcd
  171.            (setq elist (entget (setq ename (entnext ename))))
  172.            (if (= (cdr (assoc '0 elist)) "SEQEND")
  173.              (setq prcd nil)
  174.              (setq blist (append blist (list elist)))
  175.            )
  176.         )
  177.         (cdr (assoc '-1 (car blist)))
  178.      )
  179.   )
  180. )
  181.  
  182. ; eget ( tagn )
  183.  
  184. ; Searches the current blist for an ATTRIB elist with an attribute
  185. ; tag equal to the argument's tag name. It returns either the
  186. ; attribute's elist or nil.
  187.  
  188. ; Input:  tagn      - The attribute tag name
  189. ;         blist     - A global list containing the elists to be
  190. ;                     searched.
  191. ;
  192. ; Return: elist     - The desired entity list or nil
  193.  
  194. (defun eget ( tagn / elist wlist)
  195.  
  196.   (setq elist nil)
  197.   (foreach wlist blist
  198.      (if (and (= (cdr (assoc '0 wlist)) "ATTRIB")
  199.               (= (cdr (assoc '2 wlist)) tagn)
  200.          )
  201.         (setq elist wlist)
  202.      )
  203.   )
  204.   elist
  205. )
  206.  
  207. ;       GETZ  --  Obtain elevation defaulting to current elevation
  208.  
  209. (defun getz (s / z)
  210.         (setq z (getreal (strcat s " elevation <"
  211.            (rtos (getvar "elevation")) ">: ")))
  212.         (if (null z)
  213.            (setq z (getvar "elevation"))
  214.         )
  215.         z
  216. )
  217.  
  218. ;       DIVPL  --  Divide polyline into n animation steps.  One
  219. ;                  step is placed at the start and one at the
  220. ;                  end of the polyline, and n - 2 in the middle.
  221. ;                  For historical reasons, DIVPL is called with
  222. ;                  1 one greater than the number of points desired.
  223.  
  224.       (defun divpl (p n / e op tda tdb)
  225.         (if (setq op (= 0 (logand 1 (cdr (assoc 70 (entget (car p)))))))
  226.            (progn
  227.               (setq tda
  228.                  (trans (cdr (assoc 10 (entget (entnext (car p))))) (car p) 1)
  229.               )
  230.               (command "point" (list (car tda) (cadr tda)))
  231.            )
  232.         )
  233.         (command "divide" p (- n (if op 2 1)))
  234.         (if op (progn
  235.            (setq e (car p))
  236.            (while (/= "SEQEND" (cdr (assoc 0 (entget (entnext e)))))
  237.               (setq e (entnext e))
  238.            )
  239.            (setq tdb (trans (cdr (assoc 10 (entget e))) e 1))
  240.            (command "point" (list (car tdb) (cadr tdb)))
  241.         ))
  242. )
  243.  
  244. ;       UCSP -- Check for UCS-parallel entities
  245. ;
  246. ;               Input is extrusion vector.
  247. ;               Returns T if UCS-parallel, nil if not.
  248.  
  249. (defun ucsp (edir / udir arbval dx dy dz)
  250.    (setq udir   (trans '(0 0 1) 1 0 t)
  251.          dx     (- (car edir) (car udir))
  252.          dy     (- (cadr edir) (cadr udir))
  253.          dz     (- (caddr edir) (caddr udir))
  254.          arbval (/ 1.0 64.0)
  255.    )
  256.    (if (< (+ (* dx dx) (* dy dy) (* dz dz)) 1E-20)
  257.       (equal (and (< (abs (car edir)) arbval) (< (abs (cadr edir))))
  258.              (and (< (abs (car udir)) arbval) (< (abs (cadr udir))))
  259.       )
  260.       nil
  261.    )
  262. )
  263.  
  264. ;       WALKTHROUGH  --   Main walk-through generation command
  265.  
  266. (defun C:walkthrough ( / ss ssep tdc tdd tde)
  267.         (setq prcd t)
  268.         (while prcd
  269.            (setq e (entsel "\nChoose walk-through polyline: "))
  270.            (if (and e
  271.                     (= (cdr (assoc 0 (entget (car e)))) "POLYLINE")
  272.                     (< (cdr (assoc 70 (entget (car e)))) 8)
  273.                )
  274.                (if (null (assoc 210 (entget (car e))))
  275.                    (if (ucsp (trans '(0 0 1) (car e) 0 T))
  276.                       (setq prcd nil)
  277.                       (princ "\n2D polyline must be UCS-parallel!\n")
  278.                    )
  279.                    (if (ucsp (cdr (assoc 210 (entget (car e)))))
  280.                        (setq prcd nil)
  281.                        (princ "\n2D polyline must be UCS-parallel!\n")
  282.                    )
  283.                )
  284.                (princ "\nMust be a 2D polyline!\n")
  285.            )
  286.         )
  287.         (setq ep nil)
  288.         (initget (+ 1 8 16) "Path Same")
  289.         (setq samef nil)
  290.         (setq laxy (getpoint "\nChoose look-at point (or Path or Same): "))
  291.         (if (= laxy "Path")
  292.            (progn
  293.               (setq prcd t)
  294.               (while prcd
  295.                  (setq ep (entsel "\nChoose look-at path polyline: "))
  296.                  (if (and ep
  297.                         (= (cdr (assoc 0 (entget (car ep)))) "POLYLINE")
  298.                         (< (cdr (assoc 70 (entget (car ep)))) 8)
  299.                      )
  300.                      (if (null (assoc 210 (entget (car ep))))
  301.                          (if (ucsp (trans '(0 0 1) (car ep) 0 T))
  302.                             (setq prcd nil)
  303.                             (princ "\n2D polyline must be UCS-parallel!\n")
  304.                          )
  305.                          (if (ucsp (cdr (assoc 210 (entget (car ep)))))
  306.                             (setq prcd nil)
  307.                             (princ "\n2D polyline must be UCS-parallel!\n")
  308.                          )
  309.                      )
  310.                      (princ "\nMust be a 2D polyline!\n")
  311.                  )
  312.               )
  313.               (setq piz (getz "\nInitial path"))
  314.               (setq pfz (getz "\nFinal path"))
  315.            )
  316.            (if (= laxy "Same")
  317.               (setq samef t)
  318.            )
  319.         )
  320.         (setq llist nil bname nil)
  321.         (while (null bname)
  322.            (setq bname (getstring "\nBase name for path (1-3 characters): "))
  323.            (if (or (< (strlen bname) 1) (> (strlen bname) 3))
  324.               (progn
  325.                  (princ
  326.                   "Base name null or too long.  Must be 1 to 3 characters.\n")
  327.                  (setq bname nil)
  328.               )
  329.            )
  330.         )
  331.         (initget (+ 1 2 4))
  332.         (setq np (getint "\nNumber of frames: "))
  333.         (if (< np 3)
  334.            (progn
  335.               (setq np 3)
  336.               (princ "Frames set to minimum: 3\n")
  337.            )
  338.         )
  339.         (setq iz (getz "\nInitial camera"))
  340.         (setq fz (getz "\nFinal camera"))
  341.         (setq twist (getreal "\nTwist revolutions <0>: "))
  342.  
  343. ;       Acquire the names of the lights to be used in this picture
  344. ;       by letting the user select them.
  345.  
  346.         (setq objct "LIGHT")
  347.         (while (or (null llist) lname)
  348.            (setq lname (slob "\nSelect a " ": " T))
  349.  
  350. ;          Include the light name in the list of
  351. ;          objects which belong to the scene. Don't
  352. ;          do it if the light is already part of the
  353. ;          scene.
  354.  
  355.            (if lname
  356.               (progn
  357.                  (bget lname)
  358.                  (setq lname (cdr (assoc '1 (eget "SNAME"))))
  359.                  (prompt (strcat " " lname "\n"))
  360.                  (if (not (member lname llist))
  361.                     (setq
  362.                        llist (cons lname llist)
  363.                     )
  364.                     (prompt (strcat "\nLight " lname " already selected.\n"))
  365.                  )
  366.               )
  367.            )
  368.         )
  369.  
  370. ;       All user input acquired.  Now go generate the cameras and scenes.
  371.  
  372.         (setq cmdo (getvar "CMDECHO"))
  373.         (setvar "CMDECHO" 0)
  374.         (setq blippo (getvar "BLIPMODE"))
  375.         (setvar "BLIPMODE" 0)
  376.  
  377. ;       Place the temporary divide information on layer "$$DOTS"
  378.  
  379.         (setq slayer (getvar "CLAYER"))
  380.         (command "LAYER" "MAKE" "$$DOTS" "")
  381.         (command "point" '(0 0))
  382.         (setq np (1+ np))
  383.         (setq ss (entlast))
  384. ;       (command "divide" e np)
  385.         (divpl e np)
  386.         (if ep
  387.            (progn
  388.               (setq ssep (entlast))
  389. ;             (command "divide" ep np)
  390.               (divpl ep np)
  391.            )
  392.         )
  393.         (command "LAYER" "MAKE" "ASHADE" "")
  394.  
  395. ;       Now walk through the polyline and generate a camera and
  396. ;       a set containing it and every light named, all pointing to
  397. ;       the desired look-at point.
  398.  
  399.         (setq asf (open (strcat bname ".scr") "w"))
  400.         (setq mvf (open (strcat bname ".mvi") "w"))
  401.         (write-line "spercent -1" asf)
  402.         (write-line "record on" asf)
  403.  
  404.         (setq pernt 1)
  405.         (setq e el)
  406.         (setq tangle 0.0)
  407.         (while (< pernt np)
  408.            (setq en (setq ss (entnext ss)))
  409.            (setq pelev (+ iz (* (- fz iz)
  410.               (/ (- pernt 1.0) (- np 2.0)))))
  411. ; (princ "Point ") (princ pernt) (princ " elevation ") (princ pelev) (terpri)
  412.            (if ep
  413.               (progn
  414.                  (setq tdc (cdr (assoc 10 (entget (setq ssep (entnext ssep)))))
  415.                        laxy (list
  416.                                (car tdc)
  417.                                (cadr tdc)
  418.                                (+ piz (* (- pfz piz) (/ (- pernt 1.0) (- np 2.0))))
  419.                             )
  420.                  )
  421.               )
  422.            )
  423.  
  424. ;          If look at path is same as camera path, constantly look at
  425. ;          next point (and at end, look from next to last to last
  426. ;          direction from the last point).
  427.  
  428.            (if samef
  429.               (progn
  430.                  (if (< pernt (1- np))
  431.                     (setq
  432.                        plaxy laxy
  433.                        tdd (cdr (assoc 10 (entget (entnext en))))
  434.                        laxy (list (car tdd)
  435.                                   (cadr tdd)
  436.                                   (+ iz (* (- fz iz) (/ pernt (- np 2.0))))
  437.                             )
  438.                     )
  439.                     (progn
  440.                        (setq
  441.                           tdd (cdr (assoc 10 (entget (entnext en))))
  442.                           cpxy (list (car tdd) (cadr tdd) pelev)
  443.                        )
  444.                        (setq laxy (mapcar '+ cpxy
  445.                           (mapcar '- cpxy plaxy))
  446.                        )
  447.                     )
  448.                  )
  449.               )
  450.            )
  451.            (if (= 0 (getvar "WORLDUCS"))
  452.               (setq tde (trans (cdr (assoc 10 (entget en))) 0 1))
  453.               (setq tde (cdr (assoc 10 (entget en))))
  454.            )
  455.            (icl "camera"
  456.                 (list (car tde) (cadr tde) pelev)
  457.                 laxy
  458.                 (setq tcn (cname "C" pernt))
  459.            )
  460.            (ish (setq tsn (cname "S" pernt)) "CAMERA" tcn)
  461.            (setq ll llist)
  462.            (while ll
  463.               (ish tsn "LIGHT" (car ll))
  464.               (setq ll (cdr ll))
  465.            )
  466.            (setq usn (cname "s" pernt))
  467.            (write-line (strcat "scene " usn) asf)
  468.            (if twist
  469.               (progn
  470.                  (write-line (strcat "twist " (rtos tangle 2 6)) asf)
  471.                  (setq tangle (rem (+ tangle (/ (* 360.0 twist) (- np 2.0)))
  472.                     360.0))
  473.               )
  474.            )
  475.            (write-line (strcat shadecmd " " usn) asf)
  476.            (write-line usn mvf)
  477.            (setq pernt (1+ pernt))
  478.         )
  479.         (close asf)
  480.         (close mvf)
  481.         (command "erase" (ssget "X" '((8 . "$$DOTS"))) "")
  482.         (command "LAYER" "SET" slayer "")
  483.         (setvar "CMDECHO" cmdo)
  484.         (setvar "BLIPMODE" blippo)
  485.         (princ)
  486. )
  487.  
  488. ;       ANIMLENS  --  Specify nonstandard lens focal length for kinetic
  489. ;                     animation.  Causes ANIMATE to generate a "lens"
  490. ;                     script command for every frame.
  491.  
  492. (setq animlens nil)
  493. (defun C:animlens ()
  494.         (setq animlens nil)
  495.         (initget (+ 2 4))
  496.         (setq animlens
  497.            (getreal "\nAnimation lens focal length in mm <50>: "))
  498.         (princ)
  499. )
  500.  
  501. ;       ANIMATE  --  Kinetic animation command.  Writes one filmroll
  502. ;                    per frame.
  503.  
  504. (defun C:animate ( / tdc tdd tde tdf)
  505.         (setq prcd t)
  506.         (while prcd
  507.            (setq e (entsel "\nChoose camera path polyline: "))
  508.            (if (and e
  509.                     (= (cdr (assoc 0 (entget (car e)))) "POLYLINE")
  510.                     (< (cdr (assoc 70 (entget (car e)))) 8)
  511.                )
  512.                (if (null (assoc 210 (entget (car e))))
  513.                    (if (ucsp (trans '(0 0 1) (car e) 0 T))
  514.                       (setq prcd nil)
  515.                       (princ "\n2D polyline must be UCS-parallel!\n")
  516.                    )
  517.                    (if (ucsp (cdr (assoc 210 (entget (car e)))))
  518.                        (setq prcd nil)
  519.                        (princ "\n2D polyline must be UCS-parallel!\n")
  520.                    )
  521.                )
  522.                (princ "\nMust be a 2D polyline!\n")
  523.            )
  524.         )
  525.         (setq ep nil)
  526.         (initget (+ 1 8 16) "Path Same")
  527.         (setq samef nil)
  528.         (setq laxy (getpoint "\nChoose look-at point (or Path or Same): "))
  529.         (if (= laxy "Path")
  530.            (progn
  531.               (setq prcd t)
  532.               (while prcd
  533.                  (setq ep (entsel "\nChoose look-at path polyline: "))
  534.                  (if (and ep
  535.                           (= (cdr (assoc 0 (entget (car ep)))) "POLYLINE")
  536.                           (< (cdr (assoc 70 (entget (car ep)))) 8)
  537.                      )
  538.                      (if (null (assoc 210 (entget (car ep))))
  539.                          (if (ucsp (trans '(0 0 1) (car ep) 0 T))
  540.                             (setq prcd nil)
  541.                             (princ "\n2D polyline must be UCS-parallel!\n")
  542.                          )
  543.                          (if (ucsp (cdr (assoc 210 (entget (car ep)))))
  544.                              (setq prcd nil)
  545.                              (princ "\n2D polyline must be UCS-parallel!\n")
  546.                          )
  547.                      )
  548.                      (princ "\nMust be a 2D polyline!\n")
  549.                  )
  550.               )
  551.               (setq piz (getz "\nInitial path"))
  552.               (setq pfz (getz "\nFinal path"))
  553.            )
  554.            (if (= laxy "Same")
  555.               (setq samef t)
  556.            )
  557.         )
  558.  
  559.         (setq llist nil bname nil)
  560.         (while (null bname)
  561.            (setq bname (getstring "\nBase name for path (1-3 characters): "))
  562.            (if (or (< (strlen bname) 1) (> (strlen bname) 3))
  563.               (progn
  564.                  (princ
  565.                   "Base name null or too long.  Must be 1 to 3 characters.\n")
  566.                  (setq bname nil)
  567.               )
  568.            )
  569.         )
  570.         (initget (+ 1 2 4))
  571.         (setq np (getint "\nNumber of frames: "))
  572.         (if (< np 3)
  573.            (progn
  574.               (setq np 3)
  575.               (princ "Frames set to minimum: 3\n")
  576.            )
  577.         )
  578.         (setq iz (getz "\nInitial camera"))
  579.         (setq fz (getz "\nFinal camera"))
  580.         (setq twist (getreal "\nTwist revolutions <0>: "))
  581.         (setq motl nil motrot nil motzt nil prcd t)
  582.         (while prcd
  583.            (if (> (strlen (setq ml (getstring "\nLayer to move: "))) 0)
  584.               (progn
  585.                  (if (and (tblsearch "layer" ml) (ssget "X"
  586.                             (list (cons 8 ml))))
  587.                     (progn
  588.                        (setq prcd1 t)
  589.                        (while prcd1
  590.                           (setq mlp (entsel (strcat
  591.                              "\nChoose motion path polyline for " ml ": ")))
  592.                           (if (and mlp
  593.                                    (= (cdr (assoc 0 (entget
  594.                                        (car mlp)))) "POLYLINE")
  595.                                    (< (cdr (assoc 70 (entget (car mlp)))) 8)
  596.                               )
  597.                               (if (null (assoc 210 (entget (car mlp))))
  598.                                   (if (ucsp (trans '(0 0 1) (car mlp) 0 T))
  599.                                      (setq prcd1 nil)
  600.                                      (princ "\n2D polyline must be UCS-parallel!\n")
  601.                                   )
  602.                                   (if (ucsp (cdr (assoc 210 (entget (car mlp)))))
  603.                                       (setq prcd1 nil)
  604.                                       (princ "\n2D polyline must be UCS-parallel!\n")
  605.                                   )
  606.                               )
  607.                               (princ "\nMust be a 2D polyline!\n")
  608.                           )
  609.                        )
  610.                        (setq motl (append motl (list (list ml mlp))))
  611.                        (if (setq mrz (getreal "\nRotations <0>: "))
  612.                           (setq motrot (append motrot (list
  613.                              (/ (* 360.0 mrz) np))))
  614.                           (setq motrot (append motrot '(0)))
  615.                        )
  616.                        (if (setq mrz (getreal "\nZ translation <0>: "))
  617.                           (setq motzt (append motzt (list
  618.                              (/ mrz np))))
  619.                           (setq motzt (append motzt '(0)))
  620.                        )
  621.                     )
  622.                     (prompt "No such layer in drawing or layer empty.\n")
  623.                  )
  624.               )
  625.               (setq prcd nil)
  626.            )
  627.         )
  628.  
  629. ;       Acquire the names of the lights to be used in this picture
  630. ;       by letting the user select them.
  631.  
  632.         (setq objct "LIGHT")
  633.         (while (or (null llist) lname)
  634.            (setq lname (slob "\nSelect a " ": " T))
  635.  
  636. ;          Include the light name in the list of
  637. ;          objects which belong to the scene. Don't
  638. ;          do it if the light is already part of the
  639. ;          scene.
  640.  
  641.            (if lname
  642.               (progn
  643.                  (bget lname)
  644.                  (setq lname (cdr (assoc '1 (eget "SNAME"))))
  645.                  (prompt (strcat " " lname "\n"))
  646.                  (if (not (member lname llist))
  647.                     (setq
  648.                        llist (cons lname llist)
  649.                     )
  650.                     (prompt (strcat "\nLight " lname " already selected.\n"))
  651.                  )
  652.               )
  653.            )
  654.         )
  655.  
  656.         (setq cmdo (getvar "CMDECHO"))
  657.         (setvar "CMDECHO" 0)
  658.         (setq blippo (getvar "BLIPMODE"))
  659.         (setvar "BLIPMODE" 0)
  660.  
  661.         (setq slayer (getvar "CLAYER"))
  662.         (command "LAYER" "MAKE" "$$DOTS" "")
  663.         (command "point" '(0 0))
  664.         (setq np (1+ np))
  665.         (setq ss (entlast))
  666.         (divpl e np)
  667.         (if ep
  668.            (progn
  669.               (setq ssep (entlast))
  670.               (divpl ep np)
  671.            )
  672.         )
  673.  
  674. ;       Now walk through the motion layer list and create division
  675. ;       points on the polylines that trace object motion.
  676.  
  677.         (setq pernt 0 motp nil)
  678.         (while (< pernt (length motl))
  679.            (setq motp (append motp (list (entlast))))
  680.            (divpl (cadr (nth pernt motl)) np)
  681. ;          Sledgehammer to put all objects back at original position
  682. ;          at the end.  Admire, but don't emulate.
  683.            (setq tdf (trans (cdr (assoc 10 (entget (entnext (nth pernt motp))))) 0 1))
  684.            (command "point" (list (car tdf) (cadr tdf)))
  685.            (setq pernt (1+ pernt))
  686.         )
  687.  
  688.         (command "LAYER" "MAKE" "$$ANICAM" "")
  689.  
  690. ;       Now walk through the polyline and generate a camera and
  691. ;       a set containing it and every light named, all pointing to
  692. ;       the desired look-at point.
  693.  
  694.         (setq asf (open (strcat bname ".scr") "w"))
  695.         (setq mvf (open (strcat bname ".mvi") "w"))
  696.         (write-line "record on" asf)
  697.  
  698.         (setq pernt 1)
  699.         (setq e el)
  700.         (setq tangle 0.0)
  701.         (while (< pernt np)
  702.            (setq en (setq ss (entnext ss)))
  703.            (setq pelev (+ iz (* (- fz iz)
  704.               (/ (- pernt 1.0) (- np 2.0)))))
  705.            (if ep
  706.               (progn
  707.                  (setq tdc (cdr (assoc 10 (entget (setq ssep (entnext ssep)))))
  708.                        laxy (list
  709.                                (car tdc)
  710.                                (cadr tdc)
  711.                                (+ piz (* (- pfz piz) (/ (- pernt 1.0)(- np 2.0))))
  712.                             )
  713.                  )
  714.               )
  715.            )
  716.  
  717. ;          If look at path is same as camera path, constantly look at
  718. ;          next point (and at end, look from next to last to last
  719. ;          direction from the last point).
  720.  
  721.            (if samef
  722.               (progn
  723.                  (if (< pernt (1- np))
  724.                     (setq
  725.                        plaxy laxy
  726.                        tdd (cdr (assoc 10 (entget (entnext en))))
  727.                        laxy (list (car tdd)
  728.                                   (cadr tdd)
  729.                                   (+ iz (* (- fz iz) (/ pernt (- np 2.0))))
  730.                             )
  731.                     )
  732.                     (progn
  733.                        (setq
  734.                           tdd (cdr (assoc 10 (entget (entnext en))))
  735.                           cpxy (list (car tdd) (cadr tdd) pelev)
  736.                        )
  737.                        (setq laxy (mapcar '+ cpxy
  738.                           (mapcar '- cpxy plaxy))
  739.                        )
  740.                     )
  741.                  )
  742.               )
  743.            )
  744.            (if (= 0 (getvar "WORLDUCS"))
  745.               (setq tde (trans (cdr (assoc 10 (entget en))) 0 1))
  746.               (setq tde (cdr (assoc 10 (entget en))))
  747.            )
  748.            (icl "camera"
  749.                 (list (car tde) (cadr tde) pelev)
  750.                 laxy
  751.                 (setq tcn (cname "C" pernt))
  752.            )
  753.            (ish (setq tsn (cname "S" pernt)) "CAMERA" tcn)
  754.            (setq ll llist)
  755.            (while ll
  756.               (ish tsn "LIGHT" (car ll))
  757.               (setq ll (cdr ll))
  758.            )
  759.            (setq usn (cname "s" pernt))
  760.            (write-line (strcat "open" " " usn) asf)
  761.            (write-line (strcat "scene " usn) asf)
  762.            (write-line "spercent -1" asf)
  763.            (if animlens
  764.               (write-line (strcat "lens " (rtos animlens 2 6)) asf)
  765.            )
  766.            (if twist
  767.               (progn
  768.                  (write-line (strcat "twist " (rtos tangle 2 6)) asf)
  769.                  (setq tangle (rem (+ tangle (/ (* 360.0 twist) (- np 2.0)))
  770.                     360.0))
  771.               )
  772.            )
  773.            (command "filmroll" usn)
  774.            ; Get rid of camera and scene
  775.            (command "erase" (ssget "X" '((8 . "$$ANICAM"))) "")
  776.            (write-line (strcat shadecmd " " usn) asf)
  777.            (write-line usn mvf)
  778.  
  779. ;          Move everything into position for the next frame
  780.  
  781.            (setq motn 0 motu nil)
  782.            (while (< motn (length motl))
  783.               (setq me (entnext (nth motn motp)))
  784.               (command "move" (ssget "X" (list (cons 8
  785.                  (car (nth motn motl))))) ""
  786.                  (list (car (trans (cdr (assoc 10 (entget me))) 0 1))
  787.                        (cadr (trans (cdr (assoc 10 (entget me))) 0 1))
  788.                        0.0
  789.                  )
  790.                  (append
  791.                     (setq motbp
  792.                        (list (car (trans (cdr (assoc 10 (entget (entnext me)))) 0 1))
  793.                              (cadr (trans (cdr (assoc 10 (entget (entnext me)))) 0 1))
  794.                        )
  795.                     )
  796.                     (list (nth motn motzt))
  797.                  )
  798.               )
  799.               (setq motu (append motu (list me)))
  800.               (if (/= 0 (setq motor (nth motn motrot)))
  801.                  (command "rotate" (ssget "X" (list (cons 8
  802.                     (car (nth motn motl))))) ""
  803.                     motbp
  804.                     (strcat "<<" (rtos motor 2 6))
  805.                  )
  806.               )
  807.               (setq motn (1+ motn))
  808.            )
  809.            (setq motp motu)
  810.  
  811.            (setq pernt (1+ pernt))
  812.         )
  813.  
  814.         ; Reverse rotation and Z translation for moving objects
  815.  
  816.         (setq motn 0)
  817.         (while (< motn (length motl))
  818.            (setq me (entnext (nth motn motp)))
  819.            (command "move" (ssget "X" (list (cons 8
  820.               (car (nth motn motl))))) ""
  821.                  (list (car (trans (cdr (assoc 10 (entget me))) 0 1))
  822.                        (cadr (trans (cdr (assoc 10 (entget me))) 0 1))
  823.                        0.0
  824.                  )
  825.                  (append
  826.                     (setq motbp
  827.                        (list (car (trans (cdr (assoc 10 (entget me))) 0 1))
  828.                              (cadr (trans (cdr (assoc 10 (entget me))) 0 1))
  829.                        )
  830.                     )
  831.                     (list (* -1 (- np 1) (nth motn motzt)))
  832.                  )
  833.            )
  834.            (setq motu (append motu (list me)))
  835.            (if (/= 0 (setq motor (nth motn motrot)))
  836.               (command "rotate" (ssget "X" (list (cons 8
  837.                  (car (nth motn motl))))) ""
  838.                  motbp
  839.                  (strcat "<<" (rtos (* -1 (- np 1) motor) 2 6))
  840.               )
  841.            )
  842.            (setq motn (1+ motn))
  843.         )
  844.  
  845.         (close asf)
  846.         (close mvf)
  847.         (command "erase" (ssget "X" '((8 . "$$DOTS"))) "")
  848.         (command "LAYER" "SET" slayer "")
  849.         (setvar "BLIPMODE" blippo)
  850.         (setvar "CMDECHO" cmdo)
  851.         (princ)
  852. )
  853.  
  854. ;       BUTTON  --  Add a button to the image
  855.  
  856. (defun C:button ()
  857.         (initget 1)
  858.         (setq p1 (getpoint "\nFirst corner of button: "))
  859.         (initget 1)
  860.         (setq p2 (getcorner p1 "\nSecond corner of button: "))
  861.         (initget (+ 1 2 4))
  862.         (setq bn (getint "\nButton number: "))
  863.  
  864.         (setq c1 (list (min (car p1) (car p2)) (min (cadr p1) (cadr p2))))
  865.         (setq c2 (list (max (car p1) (car p2)) (max (cadr p1) (cadr p2))))
  866.  
  867.         (setq cmdo (getvar "CMDECHO"))
  868.         (setvar "CMDECHO" 0)
  869.         (setq blippo (getvar "BLIPMODE"))
  870.         (setvar "BLIPMODE" 0)
  871.  
  872.         (setq slayer (getvar "CLAYER"))
  873.         (command "LAYER" "MAKE" "$$BUTTONS" "")
  874.         (setq scolour (getvar "CECOLOR"))
  875.         (command "COLOUR" 100)
  876.         ; Draw button outline polyline
  877.         (command "PLINE" c1 (list (car c1) (cadr c2))
  878.                          c2 (list (car c2) (cadr c1))
  879.                          "c"
  880.         )
  881.         ; Label button number
  882.         (command "TEXT" "MIDDLE" (list (/ (+ (car c1) (car c2)) 2.0)
  883.            (/ (+ (cadr c1) (cadr c2)) 2.0))
  884.            (* 0.9 (- (cadr c2) (cadr c1)))
  885.            0
  886.            (itoa bn)
  887.         )
  888.         ; Draw button definition line
  889.         (command "COLOUR" (+ 100 bn))
  890.         (command "LINE" c1 c2)
  891.         (command)
  892.  
  893.  
  894.         (command "LAYER" "SET" slayer "")
  895.         (command "COLOUR" scolour)
  896.         (setvar "BLIPMODE" blippo)
  897.         (setvar "CMDECHO" cmdo)
  898.         (princ)
  899. )
  900.  
  901.